home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / C / SUPPORT.C < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-09  |  24.7 KB  |  855 lines
  1. /* SUPPORT.C
  2.  ************************************************************************
  3.  *                                    *
  4.  *        PC Scheme/Geneva 4.00 Borland C code            *
  5.  *                                    *
  6.  * (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7.  * (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8.  *                                    *
  9.  *----------------------------------------------------------------------*
  10.  *                                    *
  11.  *            Scheme Support (General)                *
  12.  *                                    *
  13.  *----------------------------------------------------------------------*
  14.  *                                    *
  15.  * Created by: John Jensen        Date: 1985            *
  16.  * Revision history:                            *
  17.  * - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18.  *                                    *
  19.  *                    ``In nomine omnipotentii dei''    *
  20.  ************************************************************************/
  21.  
  22. #include    <ctype.h>
  23. #include    <stdlib.h>
  24. #include    <string.h>
  25. #include    <dos.h>
  26. #include    <dir.h>
  27. #include    "scheme.h"
  28. #include    <bios.h>
  29.  
  30. /************************************************************************/
  31. /* Substring                                */
  32. /************************************************************************/
  33. int    ssubstr(REGPTR string, REGPTR start_reg, REGPTR end_reg)
  34. {
  35.     unsigned        str_page, str_disp;
  36.     int             i;
  37.  
  38.     str_page = CORRPAGE(string->page);
  39.     str_disp = string->disp;
  40.  
  41.     /* validate input arguments */
  42.     i = get_word(str_page, str_disp + 1);
  43.     if (i < 0)
  44.         i = i + BLK_OVHD + sizeof(POINTER);    /* adjust for small string */
  45.     if (ptype[str_page] == STRTYPE &&
  46.         start_reg->page == ADJPAGE(SPECFIX) &&
  47.         end_reg->page == ADJPAGE(SPECFIX) &&
  48.         end_reg->disp >= start_reg->disp &&
  49.         end_reg->disp <= i - BLK_OVHD) {    /* arguments o.k.-- allocate new
  50.                      * string and copy substring characters */
  51.         alloc_block(&tmp_reg, STRTYPE, end_reg->disp - start_reg->disp );
  52.         msubstr(&tmp_reg, string, start_reg->disp, end_reg->disp );
  53.         string->page = tmp_reg.page;
  54.         string->disp = tmp_reg.disp;
  55.     } else {        /* invalid arguments to substring */
  56.         set_src_error("SUBSTRING", 3, string, start_reg, end_reg);
  57.         return    -1;
  58.     }
  59.     return    0;
  60. }
  61.  
  62. /************************************************************************/
  63. /* Test if two pointers are equal?                    */
  64. /************************************************************************/
  65. sequal_p(REGPTR reg1, REGPTR reg2)
  66. {
  67.     REG        r1 = *reg1, r2 = *reg2;
  68.  
  69.     checkstack();            /* Check to make sure we haven't recursed too deeply */
  70.  
  71.     while( gettype(&r1) == LISTTYPE )    /* do lists tail-recursively */
  72.     {
  73.         REG    car1 = r1, car2 = r2;
  74.  
  75.                 /* Quick test in case the pointers are "eq?" */
  76.         if( eq( &r1, &r2 ) )
  77.             return    TRUE;
  78.  
  79.         if( gettype(&r2) != LISTTYPE )
  80.             return    FALSE;
  81.  
  82.         if( !r1.page || !r2.page )    /* if one is nil, speed up */
  83.             return    !r2.page && !r1.page;
  84.  
  85.         take_car(&car1), take_car(&car2);
  86.         if( !sequal_p( &car1, &car2 ) )
  87.             return    FALSE;
  88.         take_cdr(&r1), take_cdr(&r2);
  89.     }
  90.     /* now we've got atoms, so really do the compare */
  91.  
  92.     /* Quick test in case the pointers are "eq?" */
  93.     if( eq( &r1, &r2 ) )
  94.         return    TRUE;
  95.  
  96.     if( gettype(&r1) != gettype(&r2) )
  97.         return    FALSE;
  98.  
  99.     switch( gettype(&r1) )
  100.     {
  101.     case FLOTYPE:
  102.         return    reg2c(&r1)->flonum.data == reg2c(&r2)->flonum.data;
  103.     case BIGTYPE:
  104.     case STRTYPE:
  105.         return    mcmpstr( reg1, reg2 );
  106.     case VECTTYPE:    /* test each entry of the arrays for equality */
  107.     {
  108.         VECTOR    far *v1 = ®2c(&r1)->vector, far *v2 = ®2c(&r2)->vector;
  109.  
  110.         if( v1->len != v2->len )
  111.             return    FALSE;
  112.         for( int i = 0; i < v1->len / sizeof(POINTER) - 1; i++ )
  113.         {
  114.             REG    elem1, elem2;
  115.  
  116.             elem1.page = v1->data[i].page, elem1.disp = v1->data[i].disp;
  117.             elem2.page = v2->data[i].page, elem2.disp = v2->data[i].disp;
  118.  
  119.             if( !sequal_p( &elem1, &elem2 ) )
  120.                 return    FALSE;
  121.             v1 = ®2c(&r1)->vector, v2 = ®2c(&r2)->vector;
  122.                     /* reload them, just for sure */
  123.         }
  124.         return    TRUE;
  125.     }
  126.     default:    /* For these types, assume that "eq?-ness" is enough */
  127.         return    FALSE;
  128.     }
  129. }
  130.  
  131. /************************************************************************/
  132. /* String->Symbol                            */
  133. /************************************************************************/
  134. int    str_2_sym(REGPTR reg)
  135. {
  136.     unsigned    page, disp;
  137.     int        len;
  138.     char        *string;
  139.  
  140.     page = CORRPAGE(reg->page);
  141.     disp = reg->disp;
  142.     if (ptype[page] != STRTYPE) {
  143.         set_src_error("STRING->SYMBOL", 1, reg);
  144.         return    -1;
  145.     } else {
  146.         len = get_word(page, disp + 1);
  147.         if (len < 0)
  148.             len = len + BLK_OVHD + sizeof(POINTER);    /* adjust for small
  149.                              * string */
  150.         len -= BLK_OVHD;
  151.         if (!(string = (char *) malloc(len + 1)))
  152.             malloc_error("str_2_sym");
  153.         get_str(string, page, disp);
  154.         string[len] = '\0';
  155.         intern(reg, string, len);
  156.         rlsstr(string);
  157.     }
  158.     return    0;
  159. }
  160.  
  161. /************************************************************************/
  162. /* String->Uninterned-symbol                        */
  163. /************************************************************************/
  164. int    str_2_usym(REGPTR reg)
  165. {
  166.     unsigned    page;
  167.     int        len;
  168.     char        *string;
  169.  
  170.     page = CORRPAGE(reg->page);
  171.     if (ptype[page] != STRTYPE) {
  172.         set_src_error("STRING->UNINTERNED-SYMBOL", 1, reg);
  173.         return    -1;
  174.     } else {
  175.         len = get_word(page, reg->disp + 1);
  176.         if (len < 0)
  177.             len = len + BLK_OVHD + sizeof(POINTER);    /* adjust for small string */
  178.         len -= BLK_OVHD;
  179.         if (!(string = (char *) malloc(len + 1)))
  180.             malloc_error("str_2_usym");
  181.         get_str(string, page, reg->disp);
  182.         string[len] = '\0';
  183.         alloc_sym(reg, len);
  184.         put_sym(string, CORRPAGE(reg->page), reg->disp, ADJPAGE(NIL_PAGE), NIL_DISP, 0);
  185.         rlsstr(string);
  186.     }
  187.     return    0;
  188. }
  189.  
  190. /************************************************************************/
  191. /* Symbol->String                            */
  192. /************************************************************************/
  193. int    sym_2_str(REGPTR reg)
  194. {
  195.     unsigned    page;
  196.     char        *string;
  197.  
  198.     page = CORRPAGE(reg->page);
  199.     if (ptype[page] != SYMTYPE) {
  200.         set_src_error("SYMBOL->STRING", 1, reg);
  201.         return    -1;
  202.     } else {
  203.         string = symbol_name(page, reg->disp);
  204.         alloc_string(reg, string);
  205.         rlsstr(string);
  206.     }
  207.  
  208.     return    0;
  209. }
  210.  
  211. /************************************************************************/
  212. /* Retrieve Symbol Name                            */
  213. /*                                    */
  214. /* Purpose:  To fetch the print name of a symbol from Scheme's memory    */
  215. /* and return it in a C string.                        */
  216. /************************************************************************/
  217. char    *symbol_name(unsigned page, unsigned disp)
  218. {
  219.     char           *name = NULL;
  220.     int             length;    /* length of symbol + 1 (characters) */
  221.  
  222.     if (ptype[page] == SYMTYPE) {
  223.         length = get_word(page, disp + 1) - (BLK_OVHD + sizeof(POINTER));
  224.         if (!(name = (char *) malloc(length)))
  225.             malloc_error("symbol_name");
  226.         get_sym(name, page, disp);
  227.         name[length - 1] = '\0';
  228.     }
  229.     return     name;
  230. }
  231.  
  232. /************************************************************************/
  233. /* Retrieve String Value                        */
  234. /*                                    */
  235. /* Purpose:  To fetch the value of a string from Scheme's memory    */
  236. /* and return it in a C string.                        */
  237. /************************************************************************/
  238. char    *string_asciz(REGPTR reg)
  239. {
  240.     char        *name = NULL;
  241.     unsigned    page;
  242.     int        length;
  243.  
  244.     page = CORRPAGE(reg->page);
  245.  
  246.     if (ptype[page] == STRTYPE) {
  247.         length = get_word(page, reg->disp + 1);
  248.         if (length < 0)
  249.             length = length + BLK_OVHD + sizeof(POINTER);
  250.         length = length - BLK_OVHD + 1;
  251.         if (!(name = (char *) malloc(length)))
  252.             malloc_error("string_asciz");
  253.         get_str(name, page, reg->disp);
  254.         name[length - 1] = '\0';
  255.     }
  256.     return    name;
  257. }
  258.  
  259. /************************************************************************/
  260. /* Release String                            */
  261. /*                                    */
  262. /* Purpose:  To release the memory allocated to a C character        */
  263. /* string.  If the string is null, the free is skipped.            */
  264. /************************************************************************/
  265. void    rlsstr(char *string)
  266. {
  267.     if (string)        /* is the string allocated? */
  268.         free(string);
  269.     else
  270.         zprintf("ERROR: string null released");
  271. }
  272.  
  273. /************************************************************************/
  274. /* Convert Scheme Integer to C Long Integer                */
  275. /*                                    */
  276. /* Purpose:  To obtain the value of a Scheme integer (up to 32 bits)    */
  277. /* for manipulation by the C support routines.                */
  278. /*                                    */
  279. /* Description:  Given a Scheme pointer to an integer value, this    */
  280. /* routine returns the long integer corresponding to            */
  281. /* the value of the Scheme integer.                    */
  282. /*                                    */
  283. /* Calling Sequence:  long = int2long(value)                */
  284. /* where value - address of location where the long            */
  285. /* integer result is to be stored.                    */
  286. /* ptr - a Scheme register address containing the            */
  287. /* Scheme representation of the integer                    */
  288. /* value.                                */
  289. /* stat - return code; 0 = no errors, value returned            */
  290. /* 1 = error, integer too large or ptr                    */
  291. /* was not an integer.                            */
  292. /************************************************************************/
  293. long    int2long(REGPTR reg)
  294. {
  295.     if( ptype[CORRPAGE(reg->page)] == BIGTYPE )
  296.     {
  297.         SCHEMEOBJ    o = reg2c(reg);
  298.         long    l;
  299.  
  300.         l = o->bignum.data.data[0];
  301.         if( o->bignum.data.len > 6 )
  302.             l += ((long) o->bignum.data.data[1]) << 16;
  303.         if( o->bignum.data.sign )
  304.             l = -l;
  305.         return    l;
  306.     }
  307.     else    return    reg->disp;    /* assume it's a fixnum */
  308. }
  309.  
  310.  
  311. /************************************************************************/
  312. /* Convert C Long Integer to Scheme Integer                */
  313. /*                                    */
  314. /* Purpose:  To convert a C long integer value to the equivalent    */
  315. /* Scheme representation.                        */
  316. /*                                    */
  317. /* Description:  Given a long integer value, this routine creates the    */
  318. /* equivalent Scheme integer object and returns it in the        */
  319. /* designated register.                            */
  320. /*                                    */
  321. /* Calling Sequence:  long2int(reg, value)                */
  322. /*     where value - the Borland C long integer value to be converted     */
  323. /*              to Scheme representation                */
  324. /*        reg - a Scheme register address to hold the result.    */
  325. /************************************************************************/
  326. void    long2int(REGPTR reg, long value)
  327. {
  328.     /* determine if value can be represented as a fixnum */
  329.     if (value < 32768 && value >= -32768)
  330.         reg->page = ADJPAGE(SPECFIX), reg->disp = value;
  331.     else    enlarge(reg, value);
  332. }
  333.  
  334. /************************************************************************/
  335. /* Convert C Boolean to correct scheme representation            */
  336. /*                                    */
  337. /************************************************************************/
  338. void    bool2scm(REGPTR reg, int value)
  339. {
  340.     if( value ) {
  341.         reg->page = ADJPAGE(T_PAGE);
  342.         reg->disp = T_DISP;
  343.     } else
  344.         *reg = nil_reg;
  345. }
  346.  
  347. /************************************************************************/
  348. /* Convert scheme Boolean to C boolean                    */
  349. /*                                    */
  350. /************************************************************************/
  351. int    scm2bool(REGPTR reg)
  352. {
  353.     return eq( reg, &nil_reg );
  354. }
  355.  
  356. /************************************************************************/
  357. /* Calculate the true length of a scheme string                */
  358. /*                                    */
  359. /************************************************************************/
  360. int    regstrlen(REGPTR str)
  361. {
  362.     int    len = ( reg2c(str)->string.len );
  363.  
  364.     if( len < 0 )
  365.         len += sizeof(POINTER);
  366.     else
  367.         len -= BLK_OVHD;
  368.  
  369.     return len;
  370. }
  371.  
  372. /************************************************************************/
  373. /* Append two lists                            */
  374. /************************************************************************/
  375. int    sappend(REGPTR dest, REGPTR src)
  376. {
  377.     REG        car;
  378.     int        saved = FALSE;    /* Whether a list copy has been pushed */
  379.  
  380.     c_push(src);
  381.     c_push(src);
  382.     tm2_reg = *dest;    /* save destination operand, in case of error */
  383.     while (dest->page && ptype[CORRPAGE(dest->page)] == LISTTYPE) {
  384.         if (s_break)
  385.             restart(3);    /* shift-break? if so, start over */
  386.         take_car(&(car = *dest));
  387.         cons(src, &car, &nil_reg);
  388.         if (!saved) {
  389.             c_push(src);
  390.             saved = TRUE;
  391.         } else {
  392.             asetcdr(&tmp_reg, src);
  393.         }
  394.         tmp_reg = *src;
  395.         take_cdr(dest);
  396.     }
  397.     if (dest->page) {
  398.         if (saved)
  399.             c_pop(src);
  400.         c_pop(src);
  401.         c_pop(src);    /* Restore old SRC */
  402.         set_src_error("APPEND", 2, &tm2_reg, src);
  403.         return    -1;
  404.     }
  405.     c_pop(dest);
  406.     if (saved) {
  407.         c_pop(&tmp_reg);    /* Retrieve 2nd arg to append */
  408.         asetcdr(src, &tmp_reg);
  409.     }
  410.     c_pop(src);        /* Restore old SRC */
  411.     return    0;
  412. }
  413.  
  414. /************************************************************************/
  415. /* Start PCS Engine Timer                        */
  416. /************************************************************************/
  417. int    cset_tim(REGPTR value)
  418. {
  419.     unsigned    hi, lo;    /* parts of 32-bit value for timer */
  420.     unsigned    page;    /* page and displacement in register */
  421.     page = CORRPAGE(value->page);
  422.     hi = 0;
  423.     switch ( ptype[page] ) {
  424.     case BIGTYPE:
  425.         switch (get_word(page, value->disp + 1)) {
  426.         case 8:
  427.             hi = get_word(page, value->disp + 6);
  428.         case 6:
  429.             lo = get_word(page, value->disp + 4);
  430.             break;
  431.         default:
  432.             hi = lo = 0xffff;
  433.             break;
  434.         }
  435.         break;
  436.     case FIXTYPE:
  437.         lo = value->disp;
  438.         break;
  439.     default:
  440.         set_src_error("%START-TIMER", 1, value);
  441.     }
  442.     if (!settimer(hi, lo)) {
  443.         set_error(1, "Timer already running", &nil_reg);
  444.         return    -1;
  445.     }
  446.     return    0;
  447. }
  448.  
  449. /************************************************************************/
  450. /* Stop PCS Engine Timer and Return Value                */
  451. /************************************************************************/
  452. void    crst_tim(REGPTR value)
  453. {
  454.     long2int( value, rsttimer() );
  455. }
  456.  
  457.  
  458. /************************************************************************/
  459. /* Support for I-search in an environment                */
  460. /************************************************************************/
  461. char    *pcsrsenv = "PCS-RESERVED-SYMBOLS-ENVIRONMENT";
  462. char    *pcsksenv = "PCS-KNOWN-SYMBOLS-ENVIRONMENT";
  463.  
  464. void get_maxenv( REGPTR kn_env )
  465. {
  466.     intern( kn_env, pcsksenv, strlen( pcsksenv ) );
  467.     if ( !( sym_lookup(kn_env, &gnv_reg) && (ptype[CORRPAGE(kn_env->page)] == ENVTYPE) ) ) {
  468.         intern( kn_env, pcsrsenv, strlen( pcsrsenv ) );
  469.         if ( !( sym_lookup( kn_env, &gnv_reg) && (ptype[CORRPAGE(kn_env->page)] == ENVTYPE) ) )
  470.             *kn_env = gnv_reg;
  471.     }
  472.     return;
  473. }
  474.  
  475. /************************************************************************/
  476. /* Support for I-search in an environment                */
  477. /************************************************************************/
  478. REG    lastfound;
  479.  
  480. void    matchdone( void )
  481. {
  482.     lastfound = nil_reg;        // helps the garbage collector
  483. }
  484.  
  485. char    *matchsym( char *symbolstr, int fixlen, REGPTR sym, REGPTR pair, int *previous_found )
  486. {
  487.     char    *symbol;
  488.     int    pos;
  489.  
  490.     symbol = symbol_name( CORRPAGE(sym->page), sym->disp );
  491.     for ( pos = 0; (toupper(symbolstr[pos]) == toupper(symbol[pos])) &&
  492.                   ((pos < fixlen) || !*previous_found) &&
  493.              (symbolstr[pos] != 0); pos++ );
  494.  
  495.     if ( (symbol[pos] != 0) && (pos >= fixlen) && *previous_found )
  496.     {
  497.         int    symlower = 0;
  498.  
  499.         for ( pos = 0; symbolstr[pos] != 0; pos++ )
  500.             symlower |= islower(symbolstr[pos]);
  501.         if ( symlower ) strlwr(symbol);
  502.         lastfound = *pair;
  503.          take_cdr( pair );
  504.         tmp_reg = *sym;
  505.         tm2_reg = *pair;
  506.         return symbol;
  507.     }
  508.  
  509.     if ( (symbolstr[pos] == 0) && (symbol[pos] == 0) && eq( &lastfound, pair ) )
  510.         *previous_found = 1;
  511.     rlsstr(symbol);
  512.     return NULL;
  513. }
  514.  
  515. /************************************************************************/
  516. /* I-search in an environment (or prop list if special env is used)    */
  517. /* Calling sequence: found = ilookup( symbolstr, fixlen, page, disp )    */
  518. /*   where    symbolstr -    a ptr to null-terminated string        */
  519. /*        fixlen -    the number of character to be matched   */
  520. /*        page, disp -    of the environment to search        */
  521. /* Returns the name of the binding found (stored in tmp_reg . tm2_reg)    */
  522. /************************************************************************/
  523. char    *ilookup( char *symbolstr, int fixlen, unsigned page, unsigned disp )
  524. {
  525.     int    previous_found = ( _fstrlen( symbolstr ) == fixlen );
  526.     char    *result;
  527.     REG    proplist;
  528.     int    in_proplist;
  529.  
  530.     intern( &proplist, pcsrsenv, strlen( pcsrsenv ) ); /* find factice environment */
  531.     sym_lookup( &proplist, &gnv_reg );
  532.  
  533.     while( page )
  534.     {
  535.         SCHEMEOBJ    currenv = scheme2c( page, disp );
  536.         POINTER        parent = currenv->environment.parent;
  537.  
  538.         in_proplist = ( (page == CORRPAGE(proplist.page)) && (disp == proplist.disp) );
  539.  
  540.         if ( (currenv->environment.len == sizeof(ENVIRONMENT)) && !in_proplist )
  541.         {                /* rib format */
  542.             POINTER        names = currenv->environment.names;
  543.             POINTER        values = currenv->environment.values;
  544.             REG        nam, val;
  545.             REG        sym;
  546.             
  547.             nam.page = names.page; nam.disp = names.disp;
  548.             val.page = values.page; val.disp = values.disp;
  549.             while ( nam.page )
  550.             {
  551.                 sym = nam;
  552.                 take_car(&sym);
  553.                 result = matchsym(symbolstr, fixlen, &sym, &val, &previous_found);
  554.                 if ( result ) return result;
  555.                 take_cdr(&nam);
  556.                 take_car(&val);
  557.             }
  558.         } else {            /* hash table format */
  559.             for (int j = 0; j < HT_SIZE; j++)
  560.             {
  561.                 REG        search, pair, sym;
  562.                 
  563.                 if ( in_proplist ) {
  564.                     parent.page = gnv_reg.page; /* gnv_reg is updated */
  565.                     parent.disp = gnv_reg.disp;
  566.                     search.page = prop_page[j]; /* prop list also */
  567.                     search.disp = prop_disp[j];
  568.                 } else {                
  569.                     currenv = scheme2c( page, disp + j * sizeof(POINTER) );
  570.                     search.page = currenv->environment.names.page;
  571.                     search.disp = currenv->environment.names.disp;
  572.                 }
  573.  
  574.                 while( search.page )
  575.                 {
  576.                     pair = search;
  577.                     take_car(&pair);
  578.                     sym = pair;
  579.                     take_car(&sym);
  580.                     
  581.                     result = matchsym(symbolstr, fixlen, &sym, &pair, &previous_found);
  582.                     if ( result ) return result;
  583.                     take_cdr(&search);
  584.                 }
  585.             }
  586.         }
  587.  
  588.         page = CORRPAGE(parent.page); disp = parent.disp;
  589.     }
  590.  
  591.     return NULL; /* not found */
  592. }
  593.  
  594. /************************************************************************/
  595. /* I-search for a DOS filename                        */
  596. /* Calling sequence: found = ifile( symbolstr, fixlen )            */
  597. /*   where    symbolstr -    a ptr to null-terminated string        */
  598. /*        fixlen -    the number of character to be matched   */
  599. /* Returns the name or NULL if no completion exists            */
  600. /************************************************************************/
  601. char    *ifile( char *symbolstr, int fixlen )
  602. {
  603.     static struct find_t ffblk;
  604.     char        *pattn, *path;
  605.     char        drive[MAXDRIVE], dir[MAXDIR], name[MAXFILE], ext[MAXEXT];
  606.     int        stat;
  607.  
  608.     if( !(pattn = (char *)malloc(fixlen+4)) ||
  609.         !(path  = (char *)malloc(MAXPATH+1)) )
  610.         malloc_error("ifile");
  611.  
  612.     strncpy(pattn, symbolstr, fixlen);    // calculate file pattern
  613.     pattn[fixlen] = 0;
  614.     if( fnsplit( pattn, drive, dir, NULL, NULL ) & EXTENSION )
  615.         strcpy( pattn+fixlen, "*");
  616.     else    strcpy( pattn+fixlen, "*.*");
  617.  
  618.     if( strlen(symbolstr) == fixlen )    // search directory
  619.         stat = _dos_findfirst( pattn, FA_DIREC, &ffblk);
  620.     else
  621.         stat = _dos_findnext( &ffblk );
  622.  
  623.     while( !stat && ffblk.name[0] == '.' )
  624.         stat = _dos_findnext( &ffblk );
  625.  
  626.     if( stat ) {
  627.         strncpy( path, symbolstr, fixlen );
  628.         path[fixlen] = 0;
  629.     } else {
  630.         fnsplit( ffblk.name, NULL, NULL, name, ext );
  631.         fnmerge( path, drive, dir, name, ext );
  632.         if( ffblk.attrib & FA_DIREC )
  633.             strcat( path, "/");
  634.         else    strcat( path, "\"");
  635.         if( strlen(path) == fixlen )    // if same as root, add space
  636.              strcpy( path+fixlen, " ");
  637.         {
  638.             char *scan = symbolstr;
  639.             while(*scan && !isalpha(*scan)) scan++;
  640.             if( islower( scan[0] ) || islower( scan[1] ) )
  641.                 strlwr( path );    // translate to lower case
  642.         }
  643.     }
  644.  
  645.     rlsstr(pattn);
  646.     return    path;
  647. }
  648.  
  649. /************************************************************************/
  650. /* Scheme-Reset                                 */
  651. /************************************************************************/
  652. void    scheme_reset(void)
  653. {
  654.     unsigned    car_page, car_disp;
  655.     int        i;
  656.     unsigned    page, disp;
  657.  
  658.     /* create a pointer to the symbol "scheme-top-level" */
  659.     intern(&tmp_reg, "SCHEME-TOP-LEVEL", 16);
  660.  
  661.     /* If first call to Scheme-reset, initialize state parameters */
  662.     if (!fp_save) {
  663.         fp_save = frameptr;
  664.         page = CORRPAGE(fnv_save.page = fnv_reg.page);
  665.         disp = fnv_save.disp = fnv_reg.disp;
  666.  
  667.         /* find the binding for "scheme-top-level" */
  668.         while (page) {
  669.             car_page = CORRPAGE(get_byte(page, disp));
  670.             car_disp = get_word(page, disp + 1);
  671.             if (tmp_reg.disp == get_word(car_page, car_disp + 1) &&
  672.                 tmp_reg.page == get_byte(car_page, car_disp)) {
  673.                 stl_save.page = get_byte(car_page, car_disp + 3);
  674.                 stl_save.disp = get_word(car_page, car_disp + 4);
  675.                 break;
  676.             }
  677.             i = CORRPAGE(get_byte(page, disp + 3));
  678.             disp = get_word(page, disp + 4);
  679.             page = i;
  680.         }
  681.  
  682.         if (!page) {    /* if "scheme-top-level" not in fluids, error */
  683.             print_and_exit(
  684.                     "[VM FATAL ERROR] No fluid binding for SCHEME-TOP-LEVEL\n");
  685.         }
  686.     } else {
  687.         /* Reset fluid environment */
  688.         page = CORRPAGE(fnv_reg.page = fnv_save.page);
  689.         disp = fnv_reg.disp = fnv_save.disp;
  690.  
  691.         /* find the binding for "scheme-top-level" */
  692.         while (page) {
  693.             car_page = CORRPAGE(get_byte(page, disp));
  694.             car_disp = get_word(page, disp + 1);
  695.             if (tmp_reg.disp == get_word(car_page, car_disp + 1) &&
  696.                 tmp_reg.page == get_byte(car_page, car_disp)) {
  697.                 put_ptr(car_page, car_disp + 3, stl_save.page, stl_save.disp);
  698.                 break;
  699.             }
  700.             i = CORRPAGE(get_byte(page, disp + 3));
  701.             disp = get_word(page, disp + 4);
  702.             page = i;
  703.         }
  704.     }
  705. }
  706.  
  707. /************************************************************************/
  708. /* Reification Support                            */
  709. /************************************************************************/
  710. int    reify( int direction, REGPTR obj, REGPTR index, REGPTR val )
  711. {
  712.     SCHEMEOBJ    o;
  713.  
  714.     if( index->page != ADJPAGE(SPECFIX) )
  715.     {
  716.         if( direction )
  717.             set_src_error("%REIFY!", 3, obj, index, val);
  718.         else
  719.             set_src_error("%REIFY", 2, obj, index);
  720.         return    -1;
  721.     }
  722.  
  723.     o = reg2c(obj);
  724.  
  725.     switch( ptype[CORRPAGE(obj->page)] )
  726.     {
  727.     case LISTTYPE:
  728.         if( !direction )
  729.             obj->page = ADJPAGE(SPECFIX), obj->disp = sizeof(LIST);
  730.         break;
  731.     case FIXTYPE:
  732.     case CHARTYPE:
  733.         if( !direction )
  734.             obj->page = ADJPAGE(SPECFIX), obj->disp = sizeof(POINTER);
  735.         break;
  736.     case FLOTYPE:
  737.         if( index->disp == 0xffff )
  738.             obj->page = ADJPAGE(SPECFIX), obj->disp = sizeof(FLONUM);
  739.         else    if( direction )
  740.         {
  741.             long    l;
  742.             l = int2long( obj );
  743.             ((unsigned far *) &o->flonum.data)[index->disp] = l;
  744.         }
  745.         else    long2int( obj, ((unsigned far *) &o->flonum.data)[index->disp] );
  746.         break;
  747.     default:
  748.         POINTER    far    *p;
  749.         p = ((POINTER far *) o) + index->disp + 1;
  750.  
  751.         if( index->disp == 0xffff )
  752.                   obj->page = ADJPAGE(SPECFIX), obj->disp = o->_.len;
  753.         else    if( direction )
  754.             p->page = val->page, p->disp = val->disp;
  755.         else    obj->page = p->page, obj->disp = p->disp;
  756.         break;
  757.     }
  758.     return    0;
  759. }
  760.  
  761. #define NUM_SPEC 6
  762.  
  763. /* This code shouldn't be move into a procedure, or Borland C will call
  764.    REG::REG every 65536th call to intern... */
  765.  
  766. static char    *special_constants[NUM_SPEC] =
  767.             {"#T", "#F", "#!FALSE", "#!NULL", "#!TRUE", "#!UNASSIGNED"};
  768. static REG    spec_reg[NUM_SPEC] = {
  769.             REG( T_DISP,   ADJPAGE(T_PAGE) ),
  770.             REG( NIL_DISP, ADJPAGE(NIL_PAGE) ),
  771.             REG( NIL_DISP, ADJPAGE(NIL_PAGE) ),
  772.             REG( NIL_DISP, ADJPAGE(NIL_PAGE) ),
  773.             REG( T_DISP,   ADJPAGE(T_PAGE)   ),
  774.             REG( UN_DISP,  ADJPAGE(UN_PAGE)  ) };
  775.  
  776. void    intern(REGPTR reg, char *string, int length)
  777. {
  778.     unsigned    disp;    /* displacement of the symbol's entry */
  779.     unsigned    hash_value;    /* value returned from hashing function */
  780.     int        i, j;
  781.     unsigned    page;
  782.     char        *ptr;    /* pointer to special constant name */
  783.  
  784.     if (string[0] == '#') {
  785.         for (i = 0; i < NUM_SPEC; i++) {
  786.             if( length == strlen(special_constants[i]) ) {
  787.                 for (j = 0, ptr = special_constants[i]; j < length; j++)
  788.                     if (string[j] != *ptr++)
  789.                         goto no_match;
  790.                 *reg = spec_reg[i];
  791.                 return;
  792.             }
  793. no_match:;
  794.         }
  795.     }
  796.     hash_value = hash(string, length);
  797.     if (hash_page[hash_value] != 0) {
  798.         page = CORRPAGE(hash_page[hash_value]);
  799.         disp = hash_disp[hash_value];
  800.         while (page != 0) {
  801.             if (sym_eq(page, disp, string, length)) {
  802.                 reg->page = ADJPAGE(page);
  803.                 reg->disp = disp;
  804.                 return;
  805.             }
  806.             /* Follow hash chain link pointer to next symbol */
  807.             i = CORRPAGE(get_byte(page, disp + 3));
  808.             disp = get_word(page, disp + 4);
  809.             page = i;
  810.         }
  811.     }
  812.     /* add symbol to oblist */
  813.     alloc_sym(reg, length);
  814.     page = CORRPAGE(reg->page);
  815.     put_sym(string, page, reg->disp, hash_page[hash_value], hash_disp[hash_value],
  816.         hash_value);
  817.     hash_page[hash_value] = reg->page;
  818.     hash_disp[hash_value] = reg->disp;
  819. }
  820.  
  821. /************************************************************************
  822.  *            A New getch()                    *
  823.  ************************************************************************/
  824. static char    previous = 0;
  825.  
  826. char    GETCH(void)
  827. {
  828.     int    temp;
  829.  
  830.     if( previous )
  831.     {
  832.         int    save = previous;
  833.         previous = 0;
  834.         return    save;
  835.     }
  836.  
  837.     temp = bioskey( 0 );
  838.     if( (temp & 0xff) == 0 )
  839.         previous = temp >> 8;
  840.     return    temp & 0xff;
  841. }
  842.  
  843. int    GETCHready(void)
  844. {
  845.     int    temp;
  846.     if( previous )
  847.         return    previous;
  848.     else {
  849.         int temp = bioskey( 1 );
  850.         if( !(temp & 0xff) )
  851.             return    (temp & 0xff00) != 0;
  852.         else    return    temp & 0xff;
  853.     }
  854. }
  855.